home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / psgml / psgml-fs.el.z / psgml-fs.el
Encoding:
Text File  |  1998-05-21  |  6.6 KB  |  242 lines
  1. ;;; psgml-fs.el --- Format a SGML-file according to a style file
  2. ;; Copyright (C) 1995 Lennart Staflin
  3.  
  4. ;; Author: Lennart Staflin <lenst@lysator.liu.se>
  5. ;; Version: $Id: fs.el,v 1.3 1996/03/31 21:38:45 lenst Exp $
  6. ;; Keywords: 
  7. ;; Last edited: Thu Mar 21 22:32:27 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin)
  8.  
  9. ;;; This program is free software; you can redistribute it and/or modify
  10. ;;; it under the terms of the GNU General Public License as published by
  11. ;;; the Free Software Foundation; either version 1, or (at your option)
  12. ;;; any later version.
  13. ;;;
  14. ;;; This program is distributed in the hope that it will be useful,
  15. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;;; GNU General Public License for more details.
  18. ;;;
  19. ;;; A copy of the GNU General Public License can be obtained from this
  20. ;;; program's author (send electronic mail to lenst@lysator.liu.se) or from
  21. ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  22. ;;; 02139, USA.
  23. ;;;
  24. ;;; Commentary:
  25.  
  26. ;; The function `style-format' formats the SGML-file in the current
  27. ;; buffer according to the style defined in the file `psgml-style.fs'
  28. ;; (or the file given by the variable `fs-style').
  29.  
  30. ;; To try it load this file and open the test file example.sgml. Then
  31. ;; run the emacs command `M-x style-format'.
  32.  
  33. ;; The style file should contain a single Lisp list. The elements of
  34. ;; this list, are them self lists, describe the style for an element type. 
  35. ;; The sublists begin with the generic identifier for the element types and
  36. ;; the rest of the list are characteristic/value pairs.
  37.  
  38. ;; E.g.  ("p"  block t  left 4  top 2)
  39.  
  40. ;; Defines the style for p-elements to be blocks with left margin 4 and
  41. ;; at least to blank lines before the block.
  42.  
  43.  
  44. ;;; Code:
  45. (require 'psgml-api)
  46.  
  47. ;;;; Formatting parameters
  48.  
  49. (defvar fs-char
  50.   '((left . 0)
  51.     (first . nil)
  52.     (default-top . 0)
  53.     (default-bottom . 0)
  54.     (ignore-empty-para . nil)
  55.     (literal . nil)))
  56.  
  57. (defvar fs-special-styles
  58.   '(top bottom before after hang-from text)
  59.   "Style attribues that should not be entered in the characteristics table.")
  60.  
  61.  
  62. ;;;; Formatting engine
  63.  
  64. (defun fs-char (p)
  65.   (cdr (assq p fs-char)))
  66.  
  67. (defvar fs-para-acc ""
  68.   "Accumulate text of paragraph")
  69.  
  70. (defvar fs-hang-from nil
  71.   "Hanging indent of current pargraph")
  72.  
  73. (defvar fs-first-indent nil)
  74. (defvar fs-left-indent nil)
  75.  
  76. (defvar fs-vspace 0
  77.   "Vertical space after last paragraph")
  78.  
  79. (defun fs-addvspace (n)
  80.   (when (> n fs-vspace)
  81.     (princ (make-string (- n fs-vspace) ?\n))
  82.     (setq fs-vspace n)))
  83.        
  84.  
  85. (defun fs-para ()
  86.   (when (if (fs-char 'ignore-epmty-para)
  87.         (string-match "[^\t\n ]" fs-para-acc)
  88.       fs-left-indent)
  89.     (assert fs-left-indent)
  90.     (fs-output-para fs-para-acc fs-first-indent fs-left-indent
  91.             fs-hang-from
  92.             (fs-char 'literal))
  93.     (setq fs-vspace 0
  94.       fs-hang-from nil))
  95.   (setq fs-para-acc ""
  96.     fs-first-indent nil
  97.     fs-left-indent nil))
  98.  
  99. (defun fs-paraform-data (data)
  100.   (unless fs-left-indent
  101.     (setq fs-left-indent (fs-char 'left)
  102.       fs-first-indent (fs-char 'first)))
  103.   (setq fs-para-acc (concat fs-para-acc data)))
  104.  
  105. (defun fs-output-para (text first-indent indent hang-from literal)
  106.   (sgml-push-to-string text)
  107.   (let ((indent-tabs-mode nil)
  108.     (fill-prefix (make-string indent ? )))
  109.     (cond
  110.      (literal
  111.       (goto-char (point-max))
  112.       (unless (bolp)
  113.     (insert ?\n))
  114.       (goto-char (point-min))
  115.       (while (not (eobp))
  116.     (insert fill-prefix)
  117.     (beginning-of-line 2)))
  118.      (t
  119.       (while (re-search-forward "[ \t\n\r]+" nil t)
  120.     (replace-match " "))
  121.       (goto-char (point-min))
  122.       (delete-horizontal-space)
  123.       (insert 
  124.        (if hang-from
  125.        hang-from
  126.      (make-string (or first-indent indent) ? )))
  127.       (fill-region-as-paragraph (point-min) (point-max))
  128.       ))
  129.     (princ (buffer-string)))
  130.   (sgml-pop-entity))
  131.  
  132. (defun fs-element-content (e)
  133.   (let ((fs-para-acc ""))
  134.     (sgml-map-content e
  135.               (function fs-paraform-phrase)
  136.               (function fs-paraform-data)
  137.               nil
  138.               (function fs-paraform-entity))
  139.     fs-para-acc))
  140.  
  141. (defun fs-paraform-phrase (e)
  142.   (sgml-map-content e
  143.             (function fs-paraform-phrase)
  144.             (function fs-paraform-data)
  145.             nil
  146.             (function fs-paraform-entity)))
  147.  
  148. (defun fs-paraform-entity (entity)
  149.   (let ((entity-map (fs-char 'entity-map))
  150.     (text nil))
  151.     (when entity-map
  152.       (setq text
  153.         (loop for (name val) on entity-map by 'cddr
  154.           thereis (if (equal name (sgml-entity-name entity))
  155.                   val))))
  156.     (unless text
  157.       (setq text (sgml-entity-text entity)))
  158.     (fs-paraform-data text)))
  159.  
  160. ;;;; Style driven engine
  161.  
  162. (defvar fs-style "psgml-style.fs"
  163.   "*Style sheet to use for `style-format'.
  164. The value can be the style-sheet list, or it can be a file name
  165. \(string) of a file containing the style sheet or it can be the name
  166. \(symbol) of a variable containing the style sheet." )
  167.  
  168. (defvar fs-cached-styles nil)
  169.  
  170. (defun fs-get-style (style)
  171.   (cond ((stringp style)
  172.      (sgml-cache-catalog style
  173.                  'fs-cached-styles
  174.                  (function (lambda ()
  175.                      (read (current-buffer))))))
  176.     ((symbolp style)
  177.      (fs-get-style (symbol-value style)))
  178.     ((listp style)
  179.      style)
  180.     (t
  181.      (error "Illegal style value: %s" style))))
  182.  
  183. (defun fs-engine (e)
  184.   (fs-do-style e
  185.            (cdr (or (assoc (sgml-element-gi e) fs-style)
  186.             (assq t fs-style)))))
  187.  
  188. (defun fs-do-style (e style)
  189.   (let ((hang-from (getf style 'hang-from)))
  190.     (when hang-from
  191.       (setq fs-hang-from 
  192.         (format "%s%s "
  193.             (make-string (fs-char 'left) ? )
  194.             (eval hang-from)))))
  195.   (let ((fs-char (nconc
  196.           (loop for st on style by 'cddr
  197.             unless (memq (car st) fs-special-styles)
  198.             collect (cons (car st)
  199.                       (eval (cadr st))))
  200.           fs-char)))
  201.     (when (getf style 'block)
  202.       (fs-para)
  203.       (fs-addvspace (or (getf style 'top)
  204.             (fs-char 'default-top))))
  205.     (let ((before (getf style 'before)))
  206.       (when before
  207.     (fs-do-style e before)))
  208.     (cond ((getf style 'text)
  209.        (fs-paraform-data (eval (getf style 'text))))
  210.       (t
  211.        (sgml-map-content e
  212.                  (function fs-engine)
  213.                  (function fs-paraform-data)
  214.                  nil
  215.                  (function fs-paraform-entity))))
  216.     (let ((after (getf style 'after)))
  217.       (when after
  218.     (fs-do-style e after)))
  219.     (when (getf style 'block)
  220.       (fs-para)
  221.       (fs-addvspace (or (getf style 'bottom)
  222.             (fs-char 'default-bottom))))))
  223.  
  224. ;;;###autoload
  225. (defun style-format ()
  226.   (interactive)
  227.   (setq fs-para-acc "")
  228.   (let ((fs-style (fs-get-style fs-style)))
  229.     (with-output-to-temp-buffer "*Formatted*"
  230.       (fs-engine (sgml-top-element))
  231.       (fs-para))))
  232.          
  233.  
  234.  
  235. ;;;; Helper functions for use in style sheet
  236.  
  237. (defun fs-attval (name)
  238.   (sgml-element-attval e name))
  239.  
  240.  
  241. ;;; psgml-fs.el ends here
  242.